home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
PROGS
/
SORTSECT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-05-03
|
4KB
|
155 lines
PROGRAM SortSections;
{$M 20000,0,655000}
Uses PbMISC, PbDATA, PbOBJS, PbHIGH, PbOUT0, PbPARMS;
{
Description : Sorts a TEXT file by sections
Author : Howard Richoux
Date : 1/6/94
Last revised: 2/18/94 hnr 1.02 new libraries
Application : IBM PC and compatibles, done in Turbo Pascal 7
Status : Placed in the Public Domain by HNR Software 1/29/1994
Published in: none
}
var ndx : HOLD_object;
var secttag : string; { default '\SECTION' }
sectname : string; { default '' }
sectpos : longint; { default 0 }
sectcount : integer; { default 0 }
sectmax : integer; { default 1000}
SortToFileflag : boolean; { default false }
{*****************************************************************}
Procedure WriteIt(s : string);
begin
OUT(s);
end;
Function SameFileROOT(fn1,fn2 : string) : boolean;
begin
SameFileROOT := false;
if UpCaseStr(FileRootStr(fn1)) =
UpCaseStr(FileRootStr(fn2)) then SameFileROOT := true;
end;
Procedure GoOn;
var i : integer;
ok : boolean;
fnbak : string;
begin
if not FileExists(pCurrFName) then
begin
writeln('Input file NOT FOUND. [',pCurrFName,']');
exit;
end;
fnbak := pCurrFName; forceext(fnbak,'BAK');
if SortToFileflag and FileExists(fnbak) then
begin
writeln('Backup file already exists, please erase first. [',fnbak,']');
exit;
end;
ndx.init(sectmax);
CreateTEXTSectionIndex(pCurrFName,secttag,ndx);
ndx.sort;
sectcount := ndx.count;
if sectcount < 2 then
begin
writeln('Input file has NONE or 1 sections. Using SECTTAG =[',secttag,']');
exit;
end
else if sectcount = sectmax then
begin
writeln('Input file has TOO MANY sections. Using SECTMAX =[',sectmax,']');
exit;
end;
writeln(' found ',sectcount,' sections.');
ReadTEXTSection(pCurrFName,secttag,'',0,writeit); {do whats in front}
writeln(' copied lines prior to first section.');
if pCount < sectcount then sectcount := pCount; {for testing mainly}
for i := 1 to sectcount do
begin
ok := ndx.fetchN(i,sectname,sectpos);
ReadTEXTSection(pCurrFName,secttag,sectname,sectpos,writeit);
writeln(' copied ',i,' ', sectname);
end;
OUTdone;
writeln('Copied ',sectcount,' sections.');
if SortToFileflag then
begin
writeln('Renaming ',pcurrfname,' to ',fnbak);
ok := ForceRenameToBak(pCurrFName);
if ok then
begin
writeln('Renaming ',pOUTfile,' to ',pcurrfname);
ok := ForceRenameFile(pOUTFile,pCurrFName);
if ok then
begin
writeln('Your original file is now named [',fnbak,']');
writeln('The SORTED file is now named [',pCurrFName,']');
end
else writeln('Renaming problem. ',pOUTfile);
end
else writeln('Renaming problem.',pCurrFName);
end;
ndx.done;
end;
Procedure Init;
var s : string;
begin
SortToFileflag := false;
sectname := '';
sectpos := 0;
sectcount := 0;
pCurrFName := '';
pOutFile := '';
if paramcount > 0 then
begin
pCurrFName := UpCaseStr(paramstr(1));
SuggestExt(pCurrFName,'txt');
pOutFile := pCurrFName;
ForceExt(pOutFile,'NEW');
AddParm(1,'OUT',pOutFile);
end;
AddParm(1,'SECTTAG','{SECTION');
AddParm(1,'SECTMAX','1000');
StandardOUTInit;
secttag := GetParmStr('SECTTAG');
sectmax := GetParmNum('SECTMAX');
SortToFileflag := SameFileROOT(pCurrFName, pOUTFile);
end;
(* Main program *)
BEGIN
pProgID := 'SORTSECT 1.02';
Init;
writeln('Sorting from ',pcurrfname,' to ',poutfile);
if pCurrFName <> '' then
begin
GoOn;
end
else ShowDocFile;
end.